第 12 章交互图形

plotly 包的函数使用起来还是比较复杂的，特别是需要打磨细节以打造数据产品时，此外，其依赖相当重，仅数据处理就包含两套方法 — dplyr 和 data.table，引起很多函数冲突，可谓「苦其久矣」！因此，准备另起炉灶，开发一个新的 R 包 qplotly，取意 quick plotly，以 qplot_ly() 替代 plot_ly()。类似简化 API 的工作有 simplevis、 autoplotly、 ggfortify 和 plotme。

plotly 团队开发了 plotly.js 库，且维护了 R 接口文档 (https://plotly.com/r/)，Carson Sievert 开发了 plotly 包，配套书 Interactive web-based data visualization with R, plotly, and shiny。 Paul C. Bauer 的书 Applied Data Visualization 介绍 plotly https://bookdown.org/paul/applied-data-visualization/what-is-plotly.html

echarts4r 包基于 Apache ECharts (incubating)，ECharts 的 Python 接口 pyecharts 也非常受欢迎，基于 apexcharts.js 的 apexcharter。 ECharts2Shiny 包将 ECharts 嵌入 shiny 框架中。

timevis 创建交互式的时间线的时序可视化，它基于 Vis 的 vis-timeline 模块，支持 shiny 集成。dygraphs 包基于 dygraphs 可视化库，将时序数据可视化，更多情况见 https://dygraphs.com/。leaflet 提供 leaflet 的 R 接口。rAmCharts4 基于 amCharts 4 库， apexcharter 提供 apexcharts.js 的 R 接口。还有 billboarder 等。更完整地，请看 Etienne Bacher 维护的 R 包列表 r-js-adaptation 。

对于想了解 htmlwidgets 框架，JavaScript 响应式编程的读者，推荐 John Coene 新书 JavaScript for R

学习 plotly 和 highcharter 为代表的基于 JavaScript 的 R 包，共有四重境界：第一重是照着帮助文档的示例，示例有啥我们做啥；第二重是明白帮助文档中 R 函数和 JavaScript 函数的对应关系，能力达到 JS 库的功能边界；第三重是深度自定义一些扩展性的 JS 功能，放飞自我；第四重是重新造轮子，为所欲为。下面的介绍希望能帮助读者到达第二重境界。

plotly 是一个功能非常强大的绘制交互式图形的 R 包。它支持下载图片、添加水印、自定义背景图片、工具栏和注释⁴⁵ 等一系列细节的自定义控制。下面结合 JavaScript 库 plotly.js 一起介绍，帮助文档 ?config 没有太详细地介绍，所以我们看看 config() 函数中参数 ... 和 JavaScript 库 plot_config.js 中的功能函数是怎么对应的。图12.1 中图片下载按钮对应 toImageButtonOptions 参数，看 toImageButtonOptions 源代码，可知，它接受任意数据类型，对应到 R 里面就是列表。 watermark 和 displaylogo 都是传递布尔值（TRUE/FALSE），具体根据 JavaScript 代码中的 valType （参数值类型）决定，其它参数类似。另一个函数 layout 和函数 config() 是类似的，怎么传递参数值是根据 JavaScript 代码来的。

toImageButtonOptions: {
    valType: 'any',
    dflt: {},
    description: [
        'Statically override options for toImage modebar button',
        'allowed keys are format, filename, width, height, scale',
        'see ../components/modebar/buttons.js'
    ].join(' ')
},
displaylogo: {
    valType: 'boolean',
    dflt: true,
    description: [
        'Determines whether or not the plotly logo is displayed',
        'on the end of the mode bar.'
    ].join(' ')
},
watermark: {
    valType: 'boolean',
    dflt: false,
    description: 'watermark the images with the company\'s logo'
},

library(plotly, warn.conflicts = FALSE)
plot_ly(diamonds,
  x = ~clarity, y = ~price,
  color = ~clarity, colors = "Set1", type = "box"
) %>%
  config(
    toImageButtonOptions = list(
      format = "svg", width = 450, height = 300,
      filename = paste("plot", Sys.Date(), sep = "_")
    ), 
    modeBarButtons = list(list("toImage")),
    watermark = FALSE,
    displaylogo = FALSE, 
    locale = "zh-CN", 
    staticPlot = TRUE,
    showLink = FALSE,
    modeBarButtonsToRemove = c(
      "hoverClosestCartesian", "hoverCompareCartesian", 
      "zoom2d", "zoomIn2d", "zoomOut2d", 
      "autoScale2d", "resetScale2d", "pan2d",
      "toggleSpikelines"
    )
  ) %>%
  layout(
    template = "plotly_dark",
    images = list(
      source = "https://images.plot.ly/language-icons/api-home/r-logo.png",
      xref = "paper",
      yref = "paper",
      x = 1.00,
      y = 0.25,
      sizex = 0.2,
      sizey = 0.2,
      opacity = 0.5
    ),
    annotations = list(
      text = "DRAFT",               # 水印文本
      textangle = -30,              # 逆时针旋转 30 度
      font = list(
        size = 40,                  # 字号
        color = "gray",             # 颜色
        family = "Times New Roman"  # 字族
      ),
      opacity = 0.2,                # 透明度
      xref = "paper",
      yref = "paper",
      x = 0.5,
      y = 0.5,
      showarrow = FALSE             # 去掉箭头指示
    )
  )

图 12.1: 自定义细节

表 12.1: 交互图形的设置函数 `config()` 各个参数及其作用（部分）
参数	作用
displayModeBar	是否显示交互图形上的工具条，默认显示 `TRUE`⁴⁶。
modeBarButtons	工具条上保留的工具，如下载 `"toImage"`，缩放 `"zoom2d"`⁴⁷。
modeBarButtonsToRemove	工具条上要移除的工具，如下载和缩放图片 `c("toImage", "zoom2d")`。
toImageButtonOptions	工具条上下载图片的选项设置，包括名称、类型、尺寸等。⁴⁸
displaylogo	是否交显示互图形上 Plotly 的图标，默认显示 `TRUE`⁴⁹。
staticPlot	是否将交互图形转为静态图形，默认 `FALSE`。
locale	本土化语言设置，比如 `"zh-CN"` 表示中文。

12.1 散点图

表 12.2: 散点图类型
类型	名称
`scattercarpet`	地毯图
`scatterternary`	三元图
`scatter3d`	三维散点图
`scattergeo`	地图散点图
`scattermapbox`	地图散点图 Mapbox
`scatter`	散点图
`scattergl`	散点图 GL
`scatterpolar`	极坐标散点图
`scatterpolargl`	极坐标散点图 GL

plotly.js 提供很多图层用于绘制各类图形 https://github.com/plotly/plotly.js/tree/master/src/traces

# 折线图
plot_ly(Orange,
  x = ~age, y = ~circumference, color = ~Tree,
  type = "scatter", mode = "markers"
)

图 12.2: 其它常见图形

12.2 条形图

日常使用最多的图形无外乎散点图、柱形图（分组、堆积、百分比堆积等）

# 简单条形图
library(data.table)
diamonds <- as.data.table(diamonds)

p11 <- diamonds[, .(cnt = .N), by = .(cut)] %>%
  plot_ly(x = ~cut, y = ~cnt, type = "bar") %>%
  add_text(
    text = ~ scales::comma(cnt), y = ~cnt,
    textposition = "top middle",
    cliponaxis = FALSE, showlegend = FALSE
  )
# 分组条形图
p12 <- plot_ly(diamonds,
  x = ~cut, color = ~clarity,
  colors = "Accent", type = "histogram"
) 
# 堆积条形图
p13 <- plot_ly(diamonds,
  x = ~cut, color = ~clarity,
  colors = "Accent", type = "histogram"
) %>%
  layout(barmode = "stack")
# 百分比堆积条形图
# p14 <- plot_ly(diamonds,
#   x = ~cut, color = ~clarity,
#   colors = "Accent", type = "histogram"
# ) %>%
#   layout(barmode = "stack", barnorm = "percent") %>%
#   config(displayModeBar = F)

# 推荐使用如下方式绘制堆积条形图
dat = diamonds[, .(cnt = length(carat)), by = .(clarity, cut)] %>%
  .[, pct := round(100 * cnt / sum(cnt), 2), by = .(cut)]

p14 <- plot_ly(
  data = dat, x = ~cut, y = ~pct, color = ~clarity,
  colors = "Set3", type = "bar"
) %>%
  layout(barmode = "stack")

htmltools::tagList(p11, p12, p13, p14)

12.3 折线图

其它常见的图形还要折线图、直方图、箱线图和提琴图

# 折线图
plot_ly(Orange,
  x = ~age, y = ~circumference, color = ~Tree,
  type = "scatter", mode = "markers+lines"
)

图 12.3: 折线图

12.4 双轴图

双轴图

模拟一组数据

set.seed(2020)
dat <- data.frame(
  dt = seq(from = as.Date("2020-01-01"), to = as.Date("2020-01-31"), by = "day"),
  search_qv = sample(100000:1000000, size = 31, replace = T)
) %>%
  transform(valid_click_qv = sapply(search_qv, rbinom, n = 1, prob = 0.5)) %>%
  transform(qv_ctr = valid_click_qv / search_qv)

hoverinfo = "text" 表示 tooltips 使用指定的 text 映射，而 visible = "legendonly" 表示图层默认隐藏不展示，只在图例里显示，有时候很多条线，默认只是展示几条而已。举例如下

plot_ly(data = dat) %>%
  add_bars(
    x = ~dt, y = ~search_qv, color = I("gray80"), name = "搜索 QV",
    text = ~ paste0(
      "日期：", dt, "<br>",
      "点击 QV：", format(valid_click_qv, big.mark = ","), "<br>",
      "搜索 QV：", format(search_qv, big.mark = ","), "<br>",
      "QV_CTR：", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
    ),
    hoverinfo = "text"
  ) %>%
  add_bars(
    x = ~dt, y = ~valid_click_qv, color = I("gray60"), name = "点击 QV",
    text = ~ paste0(
      "日期：", dt, "<br>",
      "点击 QV：", format(valid_click_qv, big.mark = ","), "<br>",
      "搜索 QV：", format(search_qv, big.mark = ","), "<br>",
      "QV_CTR：", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
    ), visible = "legendonly",
    hoverinfo = "text"
  ) %>%
  add_lines(
    x = ~dt, y = ~qv_ctr, name = "QV_CTR", yaxis = "y2", color = I("gray40"),
    text = ~ paste("QV_CTR：", scales::percent(qv_ctr, accuracy = 0.01), "<br>"), 
    hoverinfo = "text",
    line = list(shape = "spline", width = 3, dash = "line")
  ) %>%
  layout(
    title = "",
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      side = "right",
      title = "QV_CTR（%）",
      # ticksuffix = "%", # 设置坐标轴单位
      tickformat = '.1%', # 设置坐标轴刻度
      showgrid = F, automargin = TRUE
    ),
    xaxis = list(title = "日期", showgrid = F, showline = F),
    yaxis = list(title = " ", showgrid = F, showline = F),
    margin = list(r = 20, autoexpand = T),
    legend = list(
      x = 0, y = 1, orientation = "h",
      title = list(text = " ")
    )
  )

图 12.4: 双轴图

12.5 直方图

plot_ly(iris,
  x = ~Sepal.Length, colors = "Greys",
  color = ~Species, type = "histogram"
)

图 12.5: 分组直方图

12.6 箱线图

# 箱线图
plot_ly(diamonds,
  x = ~clarity, y = ~price, colors = "Greys",
  color = ~clarity, type = "box"
)

图 12.6: 箱线图

12.7 提琴图

plot_ly(sleep,
  x = ~group, y = ~extra, split = ~group,
  type = "violin",
  box = list(visible = T),
  meanline = list(visible = T)
)

图 12.7: 提琴图

plotly 包含图层 27 种，见表 12.3

表 12.3: 图层
A	B	C
add_annotations	add_histogram	add_polygons
add_area	add_histogram2d	add_ribbons
add_bars	add_histogram2dcontour	add_scattergeo
add_boxplot	add_image	add_segments
add_choropleth	add_lines	add_sf
add_contour	add_markers	add_surface
add_data	add_mesh	add_table
add_fun	add_paths	add_text
add_heatmap	add_pie	add_trace

12.8 气泡图

简单图形 scatter，分布图几类，其中 scatter、heatmap、scatterpolar 支持 WebGL 绘图引擎

# https://plotly.com/r/bubble-charts/
dat <- diamonds[, .(
  carat = mean(carat),
  price = sum(price), 
  cnt = .N
), by = .(cut)]

plot_ly(
  data = dat, colors = "Greys",
  x = ~carat, y = ~price, color = ~cut, size = ~cnt,
  type = "scatter", mode = "markers",
  marker = list(
    symbol = "circle", sizemode = "diameter",
    line = list(width = 2, color = "#FFFFFF"), opacity = 0.4
  ),
  text = ~ paste(
    sep = " ", "重量：", round(carat, 2), "克拉",
    "<br>价格:", round(price / 10^6, 2), "百万"
  ),
  hoverinfo = 'text'
) %>%
  add_annotations(
    x = ~carat, y = ~price, text = ~cnt,
    showarrow = F, font = list(family = "sans")
  ) %>%
  layout(
    xaxis = list(hoverformat = ".2f"),
    yaxis = list(hoverformat = ".0f")
  )

图 12.8: 气泡图

12.9 曲线图

plot_ly(
  x = c(1, 2.2, 3), y = c(5.3, 6, 7), 
  type = "scatter", color = I("gray40"), 
  mode = "markers+lines", line = list(shape = "spline")
) %>%
  add_annotations(
    x = 2, y = 6, size = I(100),
    text = TeX("x_i \\sim N(\\mu, \\sigma)")
  ) %>% 
  layout(
    xaxis = list(showgrid = F, title = TeX("\\mu")),
    yaxis = list(showgrid = F, title = TeX("\\alpha"))
  ) %>% 
  config(mathjax = 'cdn')

图 12.9: 平滑曲线图

12.10 堆积图

plot_ly(
  data = PlantGrowth, y = ~weight,
  color = ~group, colors = "Greys",
  type = "scatter", line = list(shape = "spline"),
  mode = "lines", fill = "tozeroy"
)

12.11 热力图

其他基础图形

plot_ly(z = volcano, type = 'heatmap', colors = "Greys")

12.12 地图 I

plot_mapbox() 使用 Mapbox 提供的地图服务，因此，需要注册一个账户，获取 MAPBOX_TOKEN

data("quakes")
plot_mapbox(
  data = quakes, colors = "Greys",
  lon = ~long, lat = ~lat,
  color = ~mag, size = 2,
  type = "scattermapbox", 
  mode = "markers",
  marker = list(opacity = 0.5)
) %>%
  layout(
    title = "Fiji Earthquake",
    mapbox = list(
      zoom = 3,
      center = list(
        lat = ~ median(lat - 5),
        lon = ~ median(long)
      )
    )
  ) %>%
  config(
    mapboxAccessToken = Sys.getenv("MAPBOX_TOKEN")
  )

图 12.10: 斐济地震数据

plotly::plot_ly(
  data = quakes,
  lon = ~long, lat = ~lat,
  type = "scattergeo", mode = "markers",
  text = ~ paste0(
    "站点：", stations, "<br>",
    "震级：", mag
  ),
  marker = list(
    color = ~mag, 
    size = 10, opacity = 0.8,
    line = list(color = "white", width = 1)
  )
) %>%
  plotly::layout(geo = list(
    showland = TRUE,
    landcolor = plotly::toRGB("gray95"),
    subunitcolor = plotly::toRGB("gray85"),
    countrycolor = plotly::toRGB("gray85"),
    countrywidth = 0.5,
    subunitwidth = 0.5,
    lonaxis = list(
      showgrid = TRUE,
      gridwidth = 0.5,
      range = c(160, 190),
      dtick = 5
    ),
    lataxis = list(
      showgrid = TRUE,
      gridwidth = 0.5,
      range = c(-40, -10),
      dtick = 5
    )
  ))

图 12.11: 斐济地震带分布

dat <- data.frame(state.x77,
  stats = rownames(state.x77),
  stats_abbr = state.abb
)

plotly::plot_ly(
  data = dat,
  type = "choropleth",
  locations = ~stats_abbr,
  locationmode = "USA-states",
  colorscale = "Viridis",
  z = ~Income
) |>
  plotly::layout(
    geo = list(scope = "usa"),
    title = "1974年美国各州的人均收入",
    legend = list(title = "收入")
  ) |>
  plotly::config(displayModeBar = FALSE)

图 12.12: 美国各州收入

12.13 拟合图

plot_ly(economics,
  type = "scatter",
  x = ~date,
  y = ~uempmed,
  name = "observed unemployment",
  mode = "markers+lines",
  marker = list(
    color = "red"
  ),
  line = list(
    color = "red",
    dash = "dashed"
  )
) %>%
  add_trace(
    x = ~date,
    y = ~fitted(loess(uempmed ~ as.numeric(date))),
    name = "fitted unemployment",
    mode = "markers+lines",
    marker = list(
      color = "orange"
    ),
    line = list(
      color = "orange"
    )
  ) %>%
  layout(
    title = "失业时间",
    xaxis = list(
      title = "日期",
      showgrid = F
    ),
    yaxis = list(
      title = "失业时间（周）"
    ),
    legend = list(
      x = 0, y = 1, orientation = "v",
      title = list(text = "")
    )
  )

图 12.13: 拟合曲线

12.14 轨迹图

rasterly 百万量级的散点图

library(rasterly)
plot_ly(quakes, x = ~long, y = ~lat) %>%
  add_rasterly_heatmap()

图 12.14: 散点图

quakes %>%
  rasterly(mapping = aes(x = long, y = lat)) %>%
  rasterly_points()

图 12.14: 散点图

library(plotly)
# 读取数据
# uber 轨迹数据来自 https://github.com/plotly/rasterly
ridesDf <- readRDS(file = 'data/uber.rds')

ridesDf %>%
  rasterly(mapping = aes(x = Lat, y = Lon)) %>%
  rasterly_points()

图 12.15: 轨迹数据

12.15 三维图 (plotly)

plot_ly(z = ~volcano) %>%
  add_surface()

图 12.16: 三维图形

plot_ly(x = c(0, 0, 1), y = c(0, 1, 0), z = c(0, 0, 0)) %>%
  add_mesh()

图 12.16: 三维图形

# https://plot.ly/r/reference/#scatter3d
transform(mtcars, am = ifelse(am == 0, "Automatic", "Manual")) %>%
  plot_ly(x = ~wt, y = ~hp, z = ~qsec, 
          color = ~am, colors = c("#BF382A", "#0C4B8E")) %>%
  add_markers() %>%
  layout(scene = list(
    xaxis = list(title = "Weight"),
    yaxis = list(title = "Gross horsepower"),
    zaxis = list(title = "1/4 mile time")
  ))

图 12.16: 三维图形

12.16 甘特图

项目管理必备，如图所示，本项目拆分成7个任务，一共使用3种项目资源

# https://plotly.com/r/gantt/
# 项目拆解为一系列任务，每个任务的开始时间，持续时间和资源类型
df <- data.frame(
  task = paste("Task", 1:8),
  start = as.Date(c(
    "2016-01-01", "2016-02-20", "2016-01-01",
    "2016-04-10", "2016-06-09", "2016-04-10",
    "2016-09-07", "2016-11-26"
  )),
  duration = c(50, 25, 100, 60, 30, 150, 80, 10),
  resource = c("A", "B", "C", "C", "C", "A", "B", "B")
) %>%
  transform(end = start + duration) %>%
  transform(y = 1:nrow(.))

plot_ly(data = df) %>%
  add_segments(
    x = ~start, xend = ~end,
    y = ~y, yend = ~y,
    color = ~resource,
    mode = "lines",
    colors = "Greys", 
    line = list(width = 20),
    showlegend = F,
    hoverinfo = "text",
    text = ~ paste(
      " 任务: ", task, "<br>",
      "启动时间: ", start, "<br>",
      "周期: ", duration, "天<br>",
      "资源: ", resource
    )
  ) %>%
  layout(
    xaxis = list(
      showgrid = F,
      title = list(text = "")
    ),
    yaxis = list(
      showgrid = F,
      title = list(text = ""),
      tickmode = "array",
      tickvals = 1:nrow(df),
      ticktext = unique(df$task),
      domain = c(0, 0.9)
    ),
    annotations = list(
      list(
        xref = "paper", yref = "paper",
        x = 0.80, y = 0.1,
        text = paste0(
          "项目周期: ", sum(df$duration), " 天<br>",
          "资源类型: ", length(unique(df$resource)), " 个<br>"
        ),
        font = list(size = 12),
        ax = 0, ay = 0,
        align = "left"
      ),
      list(
        xref = "paper", yref = "paper",
        x = 0.1, y = 1,
        xanchor = "left",
        text = "项目资源管理",
        font = list(size = 20),
        ax = 0, ay = 0,
        align = "left",
        showarrow = FALSE
      )
    )
  )

图 12.17: 甘特图

12.17 帕雷托图

帕雷托图 20/80 法则

# 数据来自 https://github.com/plotly/datasets 
dat <- data.frame(
  complaint = c(
    "Small portions", "Overpriced",
    "Wait time", "Food is tasteless", "No atmosphere", "Not clean",
    "Too noisy", "Food is too salty", "Unfriendly staff", "Food not fresh"
  ),
  count = c( 621L, 789L, 109L, 65L, 45L, 30L, 27L, 15L, 12L, 9L)
)

dat <- dat[order(-dat$count), ] %>%
  transform(cumulative = round(100 * cumsum(count) / sum(count), digits = 2))

# complaint 按 count 降序排列
dat$complaint <- reorder(x = dat$complaint, X = dat$count, FUN = function(x) 1/(1 + x))

plot_ly(data = dat) %>%
  add_bars(
    x = ~complaint, y = ~count,
    showlegend = F, color = I("gray60")
  ) %>%
  add_lines(
    x = ~complaint, y = ~cumulative, yaxis = "y2",
    showlegend = F, color = I("gray40")
  ) %>%
  layout(
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      side = "right",
      title = "累积百分比（%）",
      showgrid = F
    ),
    xaxis = list(title = "投诉类型", showgrid = F, showline = F),
    yaxis = list(title = "数量", showgrid = F, showline = F)
  )

图 12.18: 帕雷托图

reorder() 对 complaint 按照降序还是升序由 FUN 函数的单调性决定，单调增对应升序，单调减对应降序

12.18 时间线

library(vistime)

pres <- data.frame(
  Position = rep(c("President", "Vice"), each = 3),
  Name = c("Washington", rep(c("Adams", "Jefferson"), 2), "Burr"),
  start = c("1789-03-29", "1797-02-03", "1801-02-03"),
  end = c("1797-02-03", "1801-02-03", "1809-02-03"),
  color = c("#cbb69d", "#603913", "#c69c6e"),
  fontcolor = c("black", "white", "black")
)

vistime(pres, col.event = "Position", col.group = "Name")

图 12.19: 时间线图

12.19 漏斗图

dat <- data.frame(
  category = c("访问", "下载", "潜客", "报价", "下单"),
  value = c(39, 27.4, 20.6, 11, 2)
) %>% 
  transform(percent = value / cumsum(value))

plot_ly(data = dat) %>%
  add_trace(
    type = "funnel",
    y = ~category,
    x = ~value,
    color = ~category, 
    colors = "Set2", 
    text = ~ paste0(value, "<br>", sprintf("%.2f%%", 100*percent)) ,
    hoverinfo = "text",
    showlegend = FALSE
  ) %>%
  layout(yaxis = list(
    categoryarray = ~category,
    title = ""
  ))

图 12.20: 漏斗图

plotly::plot_ly(data = dat) %>%
  plotly::add_trace(
    type = "funnel",
    y = ~category,
    x = ~value,
    marker = list(color = RColorBrewer::brewer.pal(n = 5, name = "Set2")),
    textposition = "auto",
    textinfo = "value+percent previous",
    hoverinfo = "none"
  ) %>%
  plotly::layout(yaxis = list(categoryarray = ~category, title = ""))

图 12.21: 漏斗图

12.20 雷达图

plot_ly(
  type = "scatterpolar", mode = "markers", fill = "toself"
) %>%
  add_trace(
    r = c(39, 28, 8, 7, 28, 39), color = I("gray40"),
    theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
    name = "学生 A"
  ) %>%
  add_trace(
    r = c(1.5, 10, 39, 31, 15, 1.5), color = I("gray80"),
    theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
    name = "学生 B"
  ) %>%
  layout(
    polar = list(
      radialaxis = list(
        visible = T,
        range = c(0, 50)
      )
    )
  )

图 12.22: 雷达图

12.21 瀑布图

盈亏图

library(plotly)
library(dplyr)

dat <- data.frame(
  x = c(
    "销售", "咨询", "净收入",
    "购买", "其他费用", "税前利润"
  ),
  y = c(60, 80, 10, -40, -20, 0),
  measure = c(
    "relative", "relative", "relative",
    "relative", "relative", "total"
  )
) %>%
  mutate(text = case_when(
    y > 0 ~ paste0("+", y),
    y == 0 ~ "",
    y < 0 ~ as.character(y)
  )) %>%
  mutate(x = factor(x, levels = c(
    "销售", "咨询", "净收入",
    "购买", "其他费用", "税前利润"
  )))

n_rows <- nrow(dat)
dat[nrow(dat), "text"] <- "累计"

# measure 取值为 'relative'/'total'/'absolute'
plotly::plot_ly(dat,
  x = ~x, y = ~y, measure = ~measure, type = "waterfall",
  text = ~text, textposition = "outside", 
  name = "收支", hoverinfo = "final", 
  connector = list(line = list(color = "gray")),
  increasing = list(marker = list(color = "#66C2A5")),
  decreasing = list(marker = list(color = "#FC8D62")),
  totals = list(marker = list(color = "#8DA0CB"))
) %>%
  plotly::layout(
    title = "2018 年收支状态",
    xaxis = list(title = "业务"),
    yaxis = list(title = "金额"),
    showlegend = FALSE
  )

图 11.98: 瀑布图

12.22 树状图

plotly 绘制 treemap 和 sunburst 图比较复杂，接口不友好， plotme 正好弥补不足。

12.23 旭日图

plotme

12.24 调色板

plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width,
  mode = "markers", type = "scatter",
  color = ~ Sepal.Length > 6, colors = c("#132B43", "#56B1F7")
)

plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter"
)

plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter", colors = "Set2"
)

plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter", colors = "Set1"
)

构造 20 个类别超出 Set1 调色板的范围，会触发警告说 Set1 没有那么多色块，但还是返回足够多的色块，也可以使用 viridis、plasma、magma 或 inferno 调色板

dat <- data.frame(
  dt = rep(seq(
    from = as.Date("2021-01-01"),
    to = as.Date("2021-01-31"), by = "day"
  ), each = 20),
  bu = rep(LETTERS[1:20], 31),
  qv = rbinom(n = 20 * 31, size = 10000, prob = runif(20 * 31))
)
# viridis
plot_ly(dat,
  x = ~dt, y = ~qv, color = ~bu, 
  mode = "markers", type = "scatter", colors = "viridis"
)

图 12.23: 调色板

12.25 时序图

dygraphs 专门用来绘制交互式时间序列图形，下面以美团股价为例，展示时间窗口筛选、坐标轴名称、刻度标签、注释、事件标注、缩放等功能

meituan <- quantmod::getSymbols("3690.HK", auto.assign = FALSE, src = "yahoo")
library(dygraphs)
# 缩放
dyUnzoom <- function(dygraph) {
  dyPlugin(
    dygraph = dygraph,
    name = "Unzoom",
    path = system.file("plugins/unzoom.js", package = "dygraphs")
  )
}

# 年月
getYearMonth <- '
  function(d) {
    var monthNames = ["01", "02", "03", "04", "05", "06","07", "08", "09", "10", "11", "12"];
    date = new Date(d);
    return date.getFullYear() + "-" + monthNames[date.getMonth()]; 
  }'

dygraph(meituan[, "3690.HK.Adjusted"], main = "美团股价走势") |> 
  dyRangeSelector(dateWindow = c(format(Sys.Date(), "%Y-01-01"), as.character(Sys.Date())))  |> 
  dyAxis(name = "x", axisLabelFormatter = getYearMonth)  |> 
  dyAxis("y", valueRange = c(0, 500), label = "美团股价")  |> 
  dyEvent("2020-01-23", "武汉封城", labelLoc = "bottom")  |> 
  dyShading(from = "2020-01-23", to = "2020-04-08", color = "#FFE6E6")  |> 
  dyAnnotation("2020-01-23", text = "武汉封城", tooltip = "武汉封城", width = 60)  |> 
  dyAnnotation("2020-04-08", text = "武汉解封", tooltip = "武汉解封", width = 60)  |> 
  dyHighlight(highlightSeriesOpts = list(strokeWidth = 2))  |> 
  dySeries(label = "调整股价")  |> 
  dyLegend(show = "follow", hideOnMouseOut = FALSE)  |> 
  dyOptions(fillGraph = TRUE, drawGrid = FALSE, gridLineColor = "lightblue")  |> 
  dyUnzoom()

图 12.24: 美团股价走势

12.26 导出静态图形

orca (Open-source Report Creator App) 软件针对 plotly.js 库渲染的图形具有很强的导出功能，安装 orca 后，plotly::orca() 函数可以将基于 htmlwidgets 的 plotly 图形对象导出为 PNG、PDF 和 SVG 等格式的高质量静态图片。

p <- plot_ly(x = 1:10, y = 1:10, color = 1:10)
orca(p, "plot.svg")

12.27 静态图形转交互图形

函数 ggplotly() 将 ggplot 对象转化为交互式 plotly 对象

gg <- ggplot(faithful, aes(x = eruptions, y = waiting)) +
  stat_density_2d(aes(fill = ..level..), geom = "polygon") +
  xlim(1, 6) +
  ylim(40, 100)

静态图形

gg

转化为 plotly 对象

ggplotly(gg)

添加动态点的注释，比如点横纵坐标、坐标文本，整个注释标签的样式（如背景色）

ggplotly(gg, dynamicTicks = "y") %>%
  style(., hoveron = "points", hoverinfo = "x+y+text", 
        hoverlabel = list(bgcolor = "white"))

12.28 地图 II

leaflet 包制作地图，斐济是太平洋上的一个岛国，处于板块交界处，经常发生地震，如下图所示，展示 1964 年来 1000 次震级大于 4 级的地震活动。

library(leaflet)
data(quakes)
# Pop 提示
quakes$popup_text <- lapply(paste(
  "编号:", "<strong>", quakes$stations, "</strong>", "<br>",
  "震深:", quakes$depth, "<br>",
  "震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)
p <- leaflet(quakes) |>
  addProviderTiles(providers$CartoDB.Positron) |>
  addCircles(lng = ~long, lat = ~lat, color = ~ pal(mag), label = ~popup_text) |>
  addLegend("bottomright",
    pal = pal, values = ~mag,
    title = "地震震级"
  ) |>
  addScaleBar(position = c("bottomleft"))
p

图 12.25: 斐济地震带

将上面的绘图部分保存为独立的 HTML 网页文件

library(htmlwidgets)
# p 就是绘图部分的数据对象
saveWidget(p, "fiji-map.html", selfcontained = T)

library(leaflet)
library(leaflet.extras)

quakes |>
  leaflet() |>
  addTiles() |>
  addProviderTiles(providers$OpenStreetMap.DE) |>
  addHeatmap(
    lng = ~long, lat = ~lat, intensity = ~mag,
    max = 100, radius = 20, blur = 10
  )

图 12.26: 斐济地震带热力图

leafletCN 提供汉化

# 地图默认放大倍数
zoom         <- 4
# 地图可以放大的倍数区间
minZoom      <- 1
maxZoom      <- 18

library(leaflet)
library(leafletCN)
library(maptools)
library(leaflet.extras)

# 热力图 heatmap
leaflet(res, options = leafletOptions(minZoom = minZoom, maxZoom = maxZoom)) |>
  amap() |>
  # setView(lng = mean(data$long), lat = mean(data$lat), zoom = zoom) |>
  setView(lng = 109, lat = 38, zoom = 4) |>
  addHeatmap(
    lng = ~long2, lat = ~lat2, intensity = ~uv, max = max(res$uv),
    blur = blur, minOpacity = minOpacity, radius = radius
  )

quakes$popup_text <- lapply(paste(
  "编号:", "<strong>", quakes$stations, "</strong>", "<br>",
  "震深:", quakes$depth, "<br>",
  "震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)

leaflet(quakes) |>
  addProviderTiles(providers$CartoDB.Positron) |>
  addCircles(
    lng = ~long, lat = ~lat,
    color = ~ pal(mag), label = ~popup_text
  ) |>
  setView(178, -20, 5) |>
  addHeatmap(
    lng = ~long, lat = ~lat, intensity = ~mag,
    blur = 20, max = 0.05, radius = 15
  ) |>
  addLegend("bottomright",
    pal = pal, values = ~mag,
    title = "地震震级"
  ) |>
  addScaleBar(position = c("bottomleft"))

12.29 动画

# https://d.cosx.org/d/422311
library(echarts4r)

data("gapminder", package = "gapminder")

titles <- lapply(unique(gapminder$year), function(x) {
  list(
    text = "Gapminder",
    left = "center"
  )
})

years <- lapply(unique(gapminder$year), function(x) {
  list(
    subtext = x,
    left = "center",
    top = "center",
    z = 0,
    subtextStyle = list(
      fontSize = 100,
      color = "rgb(170, 170, 170, 0.5)",
      fontWeight = "bolder"
    )
  )
})

# 添加一列颜色，各大洲和颜色的对应关系可自定义，调整 levels 或 labels 里面的顺序即可，也可不指定 levels ，调用其它调色板
gapminder <- within(gapminder, {
  color <- factor(
    continent,
    levels = c("Asia", "Africa", "Americas", "Europe", "Oceania"),
    labels = RColorBrewer::brewer.pal(n = 5, name = "Spectral")
  )
})

gapminder |>
  group_by(year) |>
  e_charts(x = gdpPercap, timeline = TRUE) |>
  e_scatter(
    serie = lifeExp, size = pop, bind = country,
    symbol_size = 5, name = ""
  ) |>
  e_add("itemStyle", color) |>
  e_y_axis(
    min = 20, max = 85, nameGap = 30,
    name = "Life Exp", nameLocation = "center"
  ) |>
  e_x_axis(
    type = "log", min = 100, max = 100000,
    nameGap = 30, name = "GDP / Cap", nameLocation = "center"
  ) |>
  e_timeline_serie(title = titles) |>
  e_timeline_serie(title = years, index = 2) |>
  e_timeline_opts(playInterval = 1000) |>
  e_grid(bottom = 100) |>
  e_tooltip()

# params.name 对应 bind
# params.value[0] 对应 x
# params.value[1] 对应 serie
# params.value[2] 对应 size
# tooltips 自定义
# https://stackoverflow.com/questions/50554304/displaying-extra-variables-in-tooltips-echarts4r
# 百分数处理
# https://stackoverflow.com/questions/11832914/how-to-round-to-at-most-2-decimal-places-if-necessary
mtcars |>
  tibble::rownames_to_column("model") |>
  e_charts(x = wt) |>
  e_scatter(serie = mpg, size = qsec, bind = model) |>
  e_tooltip(formatter = htmlwidgets::JS("
          function(params) {
              return (
                  '<strong>' + params.name + '</strong>' +
                  '<br />wt: ' + params.value[0] +
                  '<br />mpg: ' + params.value[1] +
                  '<br />qsec- ' + params.value[2]
              )
          }
          "))

12.30 三维图 (rgl)

ggrgl

library(rgl)
lat <- matrix(seq(90, -90, len = 50) * pi / 180, 50, 50, byrow = TRUE)
long <- matrix(seq(-180, 180, len = 50) * pi / 180, 50, 50)

r <- 6378.1 # radius of Earth in km
x <- r * cos(lat) * cos(long)
y <- r * cos(lat) * sin(long)
z <- r * sin(lat)
# 调整视角
rgl.viewpoint( theta = 0, phi = 15, fov = 60, zoom = 0.5, interactive = TRUE)

persp3d(x, y, z,
  col = "white", xlab = "", ylab = "", zlab = "",
  texture = system.file("textures/world.png", package = "rgl"),
  specular = "black", axes = FALSE, box = FALSE,
  normal_x = x, normal_y = y, normal_z = z
)

12.31 网络图

gephi 探索和可视化网络图 GraphViz

# library(igraph)

12.31.1 networkD3

networkD3 D3 非常适合绘制网络图，如网络、树状、桑基图

library(networkD3)
data(MisLinks, MisNodes) # 加载数据
head(MisLinks) # 边

##   source target value
## 1      1      0     1
## 2      2      0     8
## 3      3      0    10
## 4      3      2     6
## 5      4      0     1
## 6      5      0     1

head(MisNodes) # 节点

##              name group size
## 1          Myriel     1   15
## 2        Napoleon     1   20
## 3 Mlle.Baptistine     1   23
## 4    Mme.Magloire     1   30
## 5    CountessdeLo     1   11
## 6        Geborand     1    9

构造网络图

forceNetwork(
  Links = MisLinks, Nodes = MisNodes, Source = "source",
  Target = "target", Value = "value", NodeID = "name",
  Group = "group", opacity = 0.4
)

12.31.2 visNetwork

visNetwork 使用 vis-network.js 库绘制网络关系图 https://datastorm-open.github.io/visNetwork

library(visNetwork)

调用函数 visTree() 可视化分类模型结果

library(rpart)
library(sparkline) # 函数 visTree 需要导入 sparkline 包
res <- rpart(Species~., data=iris)
visTree(res, main = "鸢尾花分类树", width = "100%")

节点、边的属性都可以映射数据指标

12.31.3 r2d3

D3 是非常流行的 JavaScript 库，r2d3 提供了 R 接口

library(r2d3)

更加具体的使用介绍，一个复杂的案例，如何从简单配置过来，以条形图为例， D3 是一个相当强大且成熟的库，提供的案例功能要覆盖 plotly

r2d3 提供了两个样例 JS 库 baranims.js 和 barchart.js

list.files(system.file("examples/", package = "r2d3"))

## [1] "baranims.js" "barchart.js"

library(r2d3)
r2d3(
  data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
  script = system.file("examples/barchart.js", package = "r2d3")
)

图 12.27: D3 图形

r2d3(
  data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
  script = system.file("examples/baranims.js", package = "r2d3")
)

图 12.28: D3 图形

提供一个 R 包和 HTML Widgets 小练习：给 roughViz.js 写个 R 包装 https://d.cosx.org/d/421030-r-html-widgets-roughviz-js-r https://github.com/XiangyunHuang/roughviz

12.32 Python 交互图形

Plotly 的图形库

import plotly.express as px

px.scatter(
    px.data.iris(),
    x="sepal_width",
    y="sepal_length",
    color="species",
    trendline="ols",
    template="simple_white",
    labels={
        "sepal_length": "Sepal Length (cm)",
        "sepal_width": "Sepal Width (cm)",
        "species": "Species of Iris",
    },
    title="Edgar Anderson's Iris Data",
    color_discrete_sequence=px.colors.qualitative.Set2
)

不能同时使用 Python 版和 R 版的 Plotly.js 库，因为版本不一致产生冲突，而不能显示图形。

12.33 运行环境

sessionInfo()

## R version 4.2.0 (2022-04-22)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.4 LTS
## 
## Matrix products: default
## BLAS:   /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
## LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
## 
## locale:
##  [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C              
##  [3] LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8    
##  [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8   
##  [7] LC_PAPER=en_US.UTF-8       LC_NAME=C                 
##  [9] LC_ADDRESS=C               LC_TELEPHONE=C            
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## other attached packages:
##  [1] sparkline_2.0     rpart_4.1.16      visNetwork_2.1.0  networkD3_0.4    
##  [5] echarts4r_0.4.3   dplyr_1.0.9       vistime_1.2.1     rasterly_0.2.0   
##  [9] Rcpp_1.0.8.3      data.table_1.14.2 r2d3_0.2.6        dygraphs_1.1.1.6 
## [13] plotly_4.10.0     ggplot2_3.3.6     reticulate_1.25  
## 
## loaded via a namespace (and not attached):
##  [1] fs_1.5.2                   xts_0.12.1                
##  [3] RColorBrewer_1.1-3         httr_1.4.3                
##  [5] tools_4.2.0                bslib_0.3.1               
##  [7] utf8_1.2.2                 R6_2.5.1                  
##  [9] DBI_1.1.2                  lazyeval_0.2.2            
## [11] colorspace_2.0-3           withr_2.5.0               
## [13] tidyselect_1.1.2           downlit_0.4.0             
## [15] curl_4.3.2                 compiler_4.2.0            
## [17] cli_3.3.0                  assertive.properties_0.0-5
## [19] xml2_1.3.3                 isoband_0.2.5             
## [21] labeling_0.4.2             bookdown_0.26             
## [23] sass_0.4.1                 scales_1.2.0              
## [25] stringr_1.4.0              digest_0.6.29             
## [27] rmarkdown_2.14             pkgconfig_2.0.3           
## [29] htmltools_0.5.2            fastmap_1.1.0             
## [31] highr_0.9                  htmlwidgets_1.5.4         
## [33] rlang_1.0.2                TTR_0.24.3                
## [35] rstudioapi_0.13            quantmod_0.4.20           
## [37] sysfonts_0.8.8             shiny_1.7.1               
## [39] jquerylib_0.1.4            farver_2.1.0              
## [41] generics_0.1.2             zoo_1.8-10                
## [43] jsonlite_1.8.0             crosstalk_1.2.0           
## [45] magrittr_2.0.3             Matrix_1.4-1              
## [47] munsell_0.5.0              fansi_1.0.3               
## [49] lifecycle_1.0.1            stringi_1.7.6             
## [51] assertive.base_0.0-9       yaml_2.3.5                
## [53] MASS_7.3-57                grid_4.2.0                
## [55] promises_1.2.0.1           ggrepel_0.9.1             
## [57] crayon_1.5.1               lattice_0.20-45           
## [59] knitr_1.39                 pillar_1.7.0              
## [61] igraph_1.3.1               codetools_0.2-18          
## [63] glue_1.6.2                 evaluate_0.15             
## [65] png_0.1-7                  vctrs_0.4.1               
## [67] httpuv_1.6.5               gtable_0.3.0              
## [69] purrr_0.3.4                tidyr_1.2.0               
## [71] assertthat_0.2.1           cachem_1.0.6              
## [73] xfun_0.31                  mime_0.12                 
## [75] xtable_1.8-4               assertive.types_0.0-3     
## [77] later_1.3.0                viridisLite_0.4.0         
## [79] tibble_3.1.7               memoise_2.0.1             
## [81] ellipsis_0.3.2

11 数据可视化

13 数值优化

第 12 章 交互图形

12.1 散点图

12.2 条形图

12.3 折线图

12.4 双轴图

12.5 直方图

12.6 箱线图

12.7 提琴图

12.8 气泡图

12.9 曲线图

12.10 堆积图

12.11 热力图

12.12 地图 I

12.13 拟合图

12.14 轨迹图

12.15 三维图 (plotly)

12.16 甘特图

12.17 帕雷托图

12.18 时间线

12.19 漏斗图

12.20 雷达图

12.21 瀑布图

12.22 树状图

12.23 旭日图

12.24 调色板

12.25 时序图

12.26 导出静态图形

12.27 静态图形转交互图形

12.28 地图 II

12.29 动画

12.30 三维图 (rgl)

12.31 网络图

12.31.1 networkD3

12.31.2 visNetwork

12.31.3 r2d3

12.32 Python 交互图形

12.33 运行环境

第 12 章交互图形